home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 21
/
Cream of the Crop 21 (Terry Blount) (October 1996).iso
/
os2
/
freetype.zip
/
ttins.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-09-07
|
95KB
|
3,046 lines
(**************************************************************************)
(* *)
(* TTINS : The FreeType project's TrueType bytecode interpreter ! *)
(* *)
(* TrueType interpreter how-to : *)
(* *)
(* 1. Init the Font Storage Pool and load the Max Profile table. *)
(* *)
(* 2. Load the CVT and all other tables. Set the glyph scale *)
(* *)
(* 3. Call 'Init_Interpreter' with the appropriate parms taken from *)
(* the max table. *)
(* *)
(* 4. Allocate a new code range with 'Alloc_CodeRange', and load the *)
(* TrueType instructions in it. *)
(* *)
(* 5. Set 'Instruction_Trap' to TRUE if you want to debug step by step *)
(* the flow of execution. *)
(* *)
(* 6. Initialize instruction pointer using 'Goto_CodeRange' *)
(* DO NOT SET 'IP' DIRECTLY. *)
(* *)
(* 7. Call the function 'Run' !! *)
(* *)
(* *)
(* NOTE : The interpreter still lacks several features, but seems to be *)
(* reasonably functionning. Still a lot of debugging to do though *)
(* *)
(* *)
(**************************************************************************)
unit TTINS;
interface
uses TTTypes, TTError, TTVars, TTCalc;
const
MaxCodeRanges = 3;
(* There can only be 3 active code ranges at once : *)
(* - the Font Program *)
(* - the CVT Program *)
(* - a glyph's instructions set *)
type
PCodeRange = ^TCodeRange;
TCodeRange = record
Base : PStorage;
Size : Int;
end;
(* defines a code range *)
(* *)
(* code ranges can be resident to a glyph ( i.e. the Font Program) *)
(* while some others are volatile ( Glyph instructions ) *)
(* tracking the state and presence of code ranges allows function *)
(* and instruction definitions within a code range to be forgotten *)
(* when the range is discarded *)
TCodeRangeTable = array[1..MaxCodeRanges] of TCodeRange;
(* defines a function/instruction definition record *)
TDefRecord = record
Range : Int; (* in which code range is it located ? *)
Start : Int; (* where does it start ? *)
Opc : Byte; (* function #, or instruction code *)
Active : boolean; (* is it active ? *)
end;
PDefArray = ^TDefArray;
TDefArray = array[0..99] of TDefRecord;
(* defines a call record, used to manage function calls *)
TCallRecord = record
Caller_Range : Int;
Caller_IP : Int;
Cur_Count : Int;
Cur_Restart : Int;
end;
(* defines a simple call stack *)
TCallStack = array[0..99] of TCallRecord;
PCallStack = ^TCallStack;
TDefTable = record
N : Int;
I : PDefArray;
end;
DebugString = String;
var
CallTop : int; (* Call Stack top, 0 if empty *)
CallSize : int; (* Call Stack max size *)
CallStack : PCallStack; (* The current call stack *)
CodeRangeTable : TCodeRangeTable;
CodeRanges : int; (* number of currently used code ranges *)
Code : PByteArray; (* Pointer to the current code segment *)
CodeSize : int; (* Size of the current code segment *)
IP : int; (* Index of current instruction cursor *)
Storage : PStorage; (* Pointer to the current storage area *)
StoreSize : int; (* Size of the current storage area *)
Stack : PStorage; (* Pointer to the current interpreter stack *)
StackSize : int; (* Size of the current interpreter stack *)
top : int; (* Index of the interpreter stack top *)
period,
phase, (* Values used for the "Super Rounding" *)
threshold : F26dot6;
zp0, (* These are zone records *)
zp1, (* Each record has pointers to original *)
zp2, (* and current coordinates, as well as *)
Twilight, (* to the touch flags array. *)
Pts : TVecRecord; (* NOTE : Twilights and Pts are COPIED *)
(* in zp0 to zp2 as needed *)
Contours : TContourRecord; (* This record holds information about *)
(* the current glyph's contours start *)
(* and end point indexes *)
Instruction_Trap : boolean; (* Instruction Debugging. Set to TRUE *)
(* to allow step-by-step trace *)
FDefs : TDefTable;
IDefs : TDefTable;
Cur_Range : Int;
function Init_Interpreter( var Max : TMaxProfile ) : boolean;
(* Initialize Interpreter. The Font Storage Pool must be allocated, *)
(* and the MaxProfile table must be loaded *)
function Alloc_CodeRange( ASize : Int; var ARange : int ) : Pointer;
(* Allocate a new Code Range of size 'ASize'. Return a range index in ARange *)
(* returns NIL on failure *)
function Discard_CodeRange( ARange : Int ): boolean;
(* Discard a Code Range given its index *)
function Goto_CodeRange( ARange, AIP : Int ): boolean;
(* Jump to a specified range, at address AIP *)
function Cur_Length : Int;
(* Return length of current opcode, found at Code^[IP] *)
function Run : Boolean;
(* Run the interpreter with the current code range and IP *)
procedure SetScale( PtSize, Resolution, EM : Int );
(* Set the current glyph scale *)
function Get_CodeRange( ARange : Int ): PCodeRange;
(* Should be used by the debuger only *)
implementation
(****************)
(* Cur_Length *)
(* ************************************)
(* *)
(* Return the length in bytes of current opcode *)
(* at Code^[IP] *)
(* *)
(***************************************************)
function Cur_Length : int;
var
Op : byte;
begin
Op := Code^[IP];
case Op of
$40 : Cur_Length := Code^[IP+1] + 2;
$41 : Cur_Length := Code^[IP+1]*2 + 2;
$B0..$B7 : Cur_Length := Op-$B0 + 2;
$B8..$BF : Cur_Length := (Op-$B8)*2 + 3;
else
Cur_Length := 1;
end;
end;
(*********************)
(* Alloc_CodeRange *)
(* **********************************************)
(* *)
(* Allocate a new code range of size 'ASize' and returns a *)
(* range index in 'ARange'. Returns NIL on failure *)
(* ( out of code ranges, or out of memory ) *)
(* *)
(* NOTE : The Code Range is allocated by this function *)
(* *)
(******************************************************************)
function Alloc_CodeRange( ASize : Int; var ARange : int ): Pointer;
begin
if CodeRanges >= MaxCodeRanges then
begin
Error := TT_ErrMsg_Out_Of_CodeRanges;
Alloc_CodeRange := nil;
exit;
end;
inc( CodeRanges );
with CodeRangeTable[CodeRanges] do
begin
if not Alloc( ASize, Pointer(Base) ) then
begin
Error := TT_ErrMsg_Storage_Overflow;
Alloc_CodeRange := nil;
dec( CodeRanges );
exit;
end
else
Alloc_CodeRange := Base;
ARange := CodeRanges;
Size := ASize;
end;
end;
(************************)
(* Discard_CodeRanges *)
(* **************************************)
(* *)
(* Discards a coderange. The coderange must be the latest *)
(* allocated. Returns FALSE on failure. *)
(* *)
(* NOTE : This function DOES NOT reclaim storage used by *)
(* the code range !! *)
(* *)
(*************************************************************)
function Discard_CodeRange( ARange : Int ): boolean;
var
i : int;
begin
if (ARange <> CodeRanges) or (ARange = 0) then
begin
Error := TT_ErrMsg_Bad_Argument;
Discard_CodeRange := False;
exit;
end;
(* Now discard all function and instruction definitions that *)
(* are located in this code range. NOTE : We do not restore *)
(* the previous defs !! *)
for i := 0 to FDefs.N-1 do
with FDefs.I^[i] do
if Active and ( Range = ARange ) then
Active := False;
for i := 0 to IDefs.N-1 do
with IDefs.I^[i] do
if Active and ( Range = ARange ) then
Active := False;
dec( CodeRanges );
end;
(********************)
(* Goto_CodeRange *)
(* *******************************************)
(* *)
(* Switch to a new code range during execution. *)
(* *)
(**************************************************************)
function Goto_CodeRange( ARange, AIP : Int ): boolean;
begin
if (ARange<=0) or (ARange>CodeRanges) then
begin
Error := TT_ErrMsg_Bad_Argument;
Goto_CodeRange := False;
exit;
end;
with CodeRangeTable[ARange] do
begin
(* NOTE : Because the last instruction of a program may be a call *)
(* we may accept GOTOs to the first byte *after* the code *)
(* range *)
(* *)
(* XXXX A Rédiger plus clairement *)
if AIP > Size then
begin
Error := TT_ErrMsg_Code_Overflow;
Goto_CodeRange := False;
exit;
end;
Code := PByteArray(Base);
CodeSize := Size;
IP := AIP;
end;
Cur_Range := ARange;
Goto_CodeRange := True;
end;
function Get_CodeRange;
begin
if (ARange<=0) or (ARange>CodeRanges) then
Get_CodeRange := nil
else
Get_CodeRange := @CodeRangeTable[ARange];
end;
(**************)
(* GetShort *)
(* *************************************)
(* *)
(* This function returns a short integer stored *)
(* in the code segment at address IP. *)
(* *)
(* It should be made inline for best performance *)
(* but we want an easy an readable program *)
(* *)
(**************************************************)
function GetShort : Short;
var
L : Array[0..1] of Byte;
begin
L[1] := Code^[IP]; inc(IP);
L[0] := Code^[IP]; inc(IP);
GetShort := Short(L);
end;
(*************)
(* GetLong *)
(* **************************************)
(* *)
(* This function returns a long integer stored *)
(* in the code segment at address IP. *)
(* *)
(* It should be inline for best performance *)
(* but we want an easy and readable program *)
(* *)
(**************************************************)
function GetLong : Long;
var L : Array[0..3] of Byte;
begin
L[3] := Code^[IP]; inc(IP);
L[2] := Code^[IP]; inc(IP);
L[1] := Code^[IP]; inc(IP);
L[0] := Code^[IP]; inc(IP);
GetLong := Long(L);
end;
(***********)
(* Touch *)
(* ****************************************)
(* *)
(* Marks a point as touched according to the *)
(* freedom vector FV. *)
(* *)
(**************************************************)
procedure Touch( var B : Byte );
begin
with GS.freeVector do
begin
if x <> 0 then B:=B or TTFlagTouchedX;
if y <> 0 then B:=B or TTFlagTouchedY;
end
end;
(**************)
(* SetScale *)
(* *************************************)
(* *)
(* Determines values for the current scale *)
(* quotient. *)
(* *)
(* Pixels = ( FUnits * Scale1 ) / Scale2 *)
(* *)
(* Scale1 = PointSize * Resolution *)
(* Scale2 = 72 * EM *)
(* *)
(**************************************************)
procedure SetScale( PtSize, Resolution, EM : Int );
begin
PointSize := PtSize*64;
Scale1 := PtSize*Resolution;
Scale2 := 72*EM;
end;
(************)
(* Scaled *)
(* ***************************************)
(* *)
(* Converts FUnits to Pixels, using the current *)
(* scale. *)
(* *)
(**************************************************)
function Scaled( L : Longint ) : LongInt;
begin
Scaled := MulDiv( L, Scale1, Scale2 );
end;
(****************)
(* Compensate *)
(* ***********************************)
(* *)
(* Compensate a distance according to its type *)
(* ( white, black or gray ) *)
(* # TO DO # *)
(* *)
(**************************************************)
function Compensate( var L : Long; Op : Byte ): boolean;
var
R : Boolean;
begin
R := Op < 3;
if not R then Error:=TT_ErrMsg_Invalid_Distance;
Compensate:= R;
end;
(*******************)
(* SetSuperRound *)
(* ********************************)
(* *)
(* Set Super Round parameters. *)
(* *)
(**************************************************)
procedure SetSuperRound( GridPeriod : F26dot6; OpCode : Byte );
begin
Case OpCode and $C0 of
$00 : period := GridPeriod div 2;
$40 : period := GridPeriod;
$80 : period := GridPeriod * 2;
(* This opcode is reserved, but ... *)
$C0 : period := GridPeriod;
end;
Case OpCode and $30 of
$00 : phase := 0;
$10 : phase := period div 4;
$20 : phase := period div 2;
$30 : phase := gridPeriod*3 div 4;
end;
if Opcode and $F = 0 then Threshold := Period-1
else
Threshold := (Integer( OpCode and $F )-4)*period div 8;
period := period div 256;
phase := phase div 256;
threshold := threshold div 256;
end;
(*************)
(* ToRound *)
(* **************************************)
(* *)
(* Rounds a parameter value according to the *)
(* current round state. *)
(* *)
(**************************************************)
function ToRound( L: Long ): Long;
var
L2 : LongInt;
begin
Case GS.roundState of
TTRoundOff : ToRound := L;
TTRoundToHalfGrid : ToRound := ( L and -64 ) + 32;
TTRoundToGrid : ToRound := ( L+32 ) and -64;
TTRoundToDoubleGrid : ToRound := (( 2*L+32 ) and -64) div 2;
TTRoundUpToGrid : ToRound := ( L+63 ) and -64;
TTRoundDownToGrid : ToRound := L and -64;
TTRoundSuper : begin
L2 := L;
(* TODO TODO *)
(* We need to include engine compensation *)
(* right here ! HOW ????!? *)
(* *)
L := L-Phase;
L := L+Threshold;
L := Period*( L div Period );
L := L+Phase;
if (L<0) and (L2>0) then L:=Phase
else
if (L>0) and (L2<0) then L:=Phase-Period;
ToRound:=L;
end
else
ToRound:=L;
end;
end;
(****************)
(* RoundPoint *)
(* ***********************************)
(* *)
(* Rounds a point's coordinates according to *)
(* the current round state and the projection *)
(* vector. *)
(* *)
(**************************************************)
procedure RoundPoint( Var V : TVector );
begin
if GS.projVector.y = 0 then
V.x:=ToRound(V.x)
else
if GS.projVector.x = 0 then
V.y:=ToRound(V.y)
else
begin
(* Right now, there is no rounding when projecting along *)
(* an axis that is not coordinate *)
end
end;
(**************)
(* SkipCode *)
(* *************************************************)
(* *)
(* Increments the current instruction pointer to the next *)
(* instruction, and verifies that we are still within the *)
(* current code segment. *)
(* *)
(* Returns False when leaving code segment *)
(* *)
(**************************************************************)
function SkipCode : boolean;
var L : Byte;
begin
SkipCode := False;
if IP < CodeSize then
begin
inc( IP, Cur_Length );
SkipCode := ( IP < CodeSize );
end;
end;
(**********)
(* Push *)
(* ************************************************************)
(* *)
(* Pushes a long integer value on the parameter stack. *)
(* Returns false in case of Stack_Overflow ( in which case the *)
(* 'Error' variable is set to TT_ErrMsg_Stack_Overflow *)
(* *)
(*********************************************************************)
function Push( l : Longint ) : boolean;
begin
if top<stackSize then
begin
stack^[top]:=l;
inc( top );
Push:=True;
end
else
begin
Error:=TT_ErrMsg_Stack_Overflow;
Push:=False;
end;
end;
(***********)
(* Push2 *)
(* *********************************************************)
(* *)
(* pushes TWO long integer values onto the parameter stack, and *)
(* returns False in case of overflow. *)
(* *)
(* Note : L1 is pushed before L2 *)
(* *)
(*******************************************************************)
function Push2( l1, l2 : LongInt ): boolean;
begin
if top+2<=stackSize then
begin
stack^[top]:=l1;
stack^[top+1]:=l2;
inc( top, 2 );
Push2:=true;
end
else
begin
Error:=TT_ErrMsg_Stack_Overflow;
Push2:=False;
end
end;
(*********)
(* Pop *)
(* ***********************************************************)
(* *)
(* Pops a long integer from the stack. Returns False if the stack *)
(* is empty on call; in which case the 'Error' variable will be *)
(* set to 'TT_ErrMsg_Too_Few_Arguments'. *)
(* *)
(*******************************************************************)
function Pop( var L : LongInt ): boolean;
begin
if top<1 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
Pop:=False;
end
else
begin
dec( top );
L:=stack^[top];
Pop:=True;
end;
end;
(**********)
(* Pop2 *)
(* **********************************************************)
(* *)
(* Pops TWO long ints from the stack. Returns False is *)
(* the stack is empty on call, r only holds one element. *)
(* *)
(* Note : K is popped before L *)
(* *)
(*******************************************************************)
function Pop2( var K, L : LongInt ): boolean;
begin
if top<2 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
Pop2:=False;
end
else
begin
dec(top,2);
K:=stack^[top+1];
L:=stack^[top];
Pop2:=true;
end
end;
(**************)
(* PopPoint *)
(* *******************************************************)
(* *)
(* Pops a point reference L from the parameter stack. Checks that *)
(* the reference is less than N. Returns False on failure, 'Error' *)
(* containing the Error raised ( empty stack or invalid ref ) *)
(* *)
(********************************************************************)
function PopPoint( var L : LongInt; N : Int ) : boolean;
begin
PopPoint:=False;
if Pop(L) then
if ( L<N ) then PopPoint:=True
else
Error:=TT_ErrMsg_Invalid_Reference;
end;
(***************)
(* PopPoint2 *)
(* ******************************************************)
(* *)
(* Pops TWO point references, that must be less than N1 and N2, *)
(* respectively. NOTE : K is popped before L *)
(* *)
(********************************************************************)
function PopPoint2( var K, L : LongInt; N1, N2 : Int ): boolean;
begin
PopPoint2:=False;
if Pop2( K,L ) then
if ( K<N1 ) and ( L<N2 ) then PopPoint2 := True
else
Error:=TT_ErrMsg_Invalid_Reference;
end;
(****************************************************************)
(* *)
(* RUN *)
(* *)
(* This function executes a run of opcodes. It will exit *)
(* in the following cases : *)
(* *)
(* - Errors ( in which case it returns FALSE ) *)
(* *)
(* - Reaching the end of the main code range (returns TRUE) *)
(* reaching the end of a code range within a function *)
(* call is an error. *)
(* *)
(* - After executing one single opcode, if the flag *)
(* 'Instruction_Trap' is set to TRUE. (returns TRUE) *)
(* *)
(* On exit whith TRUE, test IP < CodeSize to know wether it *)
(* comes from a instruction trap or a normal termination *)
(* *)
(* *)
(* Note : The documented DEBUG opcode pops a value from *)
(* the stack. This behaviour is unsupported, here *)
(* a DEBUG opcode is always an error. *)
(* *)
(* *)
(* THIS IS THE INTERPRETER'S MAIN LOOP *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
function Run : Boolean;
label
SuiteLabel,
No_Error,
ErrorLabel;
var
OpCode : Byte;
nIFs : Byte; (* Number of nested Ifs *)
zp : TVecRecord;
Vec : TVector;
UVec1,
UVec2 : TUnitVector;
Sign,
Out : boolean;
S : Short;
I, J : Int;
T : Int64;
A, B, C,
K,
L : Long;
begin
Repeat
OpCode:=Code^[IP];
Case OpCode of
(****************************************************************)
(* *)
(* MANAGING THE STACK *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* DUP[] : Duplicate top stack element *)
(* CodeRange : $20 *)
$20 : if top=0 then
begin
Error := TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end
else
if not Push( Stack^[top-1] ) then goto ErrorLabel;
(*******************************************)
(* POP[] : POPs the stack's top elt. *)
(* CodeRange : $21 *)
$21 : if not Pop(L) then goto ErrorLabel;
(*******************************************)
(* CLEAR[] : Clear the entire stack *)
(* CodeRange : $22 *)
$22 : top:=0;
(*******************************************)
(* SWAP[] : Swap the top two elements *)
(* CodeRange : $23 *)
$23 : if top<2 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end
else
begin
L:=stack^[top-1];
stack^[top-1]:=stack^[top-2];
stack^[top-2]:=L;
end;
(*******************************************)
(* DEPTH[] : return the stack depth *)
(* CodeRange : $24 *)
$24 : if not Push(top) then goto ErrorLabel;
(*******************************************)
(* CINDEX[] : copy indexed element *)
(* CodeRange : $25 *)
$25 : begin
if not Pop(L) then goto ErrorLabel;
if (L=0) or (top<L) then
begin
Error:=TT_ErrMsg_Bad_Argument;
goto ErrorLabel;
end;
if not Push( stack^[top-l] ) then goto ErrorLabel;
end;
(*******************************************)
(* MINDEX[] : move indexed element *)
(* CodeRange : $26 *)
$26 : begin
if not Pop(L) then goto ErrorLabel;
if (L=0) or (top<L) then
begin
Error:=TT_ErrMsg_Bad_Argument;
goto ErrorLabel;
end;
K:= stack^[top-l];
move( stack^[top-l+1], stack^[top-l], l-1 );
stack^[top-1]:=k;
end;
(*******************************************)
(* ROLL[] : roll top three elements *)
(* CodeRange : $8A *)
$8A : if top<3 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end
else
begin
A:=stack^[top-3];
B:=stack^[top-2];
C:=stack^[top-1];
stack^[top-1]:=A;
stack^[top-2]:=C;
stack^[top-3]:=B;
end;
(****************************************************************)
(* *)
(* MANAGING THE FLOW OF CONTROL *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* IF[] : IF test *)
(* CodeRange : $58 *)
$58 : begin
if not Pop(L) then goto ErrorLabel;
if L=0 then
begin
nIfs:=1;
Out:=False;
Repeat
if not SkipCode then goto ErrorLabel;
Case Code^[IP] of
(* IF *)
$58 : inc( nIfs );
(* ELSE *)
$1B : out:= nIfs=1;
(* EIF *)
$59 : begin
dec( nIfs );
out:= nIfs=0;
end;
end;
until Out;
end;
end;
(*******************************************)
(* ELSE[] : ELSE *)
(* CodeRange : $1B *)
$1B : begin
nIfs:=1;
Repeat
if not SkipCode then goto ErrorLabel;
Case Code^[IP] of
(* IF *)
$58 : inc( nIfs );
(* EIF *)
$59 : dec( nIfs );
end;
until nIfs=0;
end;
(*******************************************)
(* EIF[] : End IF *)
(* CodeRange : $59 *)
$59 : ; (* Intentional *)
(*******************************************)
(* JROT[] : Jump Relative On True *)
(* CodeRange : $78 *)
$78 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if K<>0 then
begin
Inc( IP, L );
goto SuiteLabel;
end;
end;
(*******************************************)
(* JMPR[] : JuMP Relative *)
(* CodeRange : $1C *)
$1C : begin
if not Pop( K ) then goto ErrorLabel;
Inc( IP, K );
goto SuiteLabel;
end;
(*******************************************)
(* JROF[] : Jump Relative On False *)
(* CodeRange : $79 *)
$79 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if K=0 then
begin
Inc( IP, L );
goto SuiteLabel;
end;
end;
(****************************************************************)
(* *)
(* LOGICAL FUNCTIONS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* LT[] : Less Than *)
(* CodeRange : $50 *)
$50 : begin
if top<2 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end;
(* This is an UNSIGNED LONG comparison *)
if stack^[top-1] < stack^[top-2] then
Stack^[top-2]:=1 else Stack^[top-2]:=0;
dec(top);
end;
(*******************************************)
(* LTEQ[] : Less Than or EQual *)
(* CodeRange : $51 *)
$51 : begin
if top<2 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end;
(* This is an UNSIGNED LONG comparison *)
if stack^[top-1] <= stack^[top-2]
then
Stack^[top-2] := 1
else
Stack^[top-2] := 0;
dec(top);
end;
(*******************************************)
(* GT[] : Greater Than *)
(* CodeRange : $52 *)
$52 : begin
if top<2 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end;
(* This is an UNSIGNED LONG comparison *)
if stack^[top-1] > stack^[top-2] then
Stack^[top-2]:=1 else Stack^[top-2]:=0;
dec(top);
end;
(*******************************************)
(* GTEQ[] : Greater Than or EQual *)
(* CodeRange : $53 *)
$53 : begin
if top<2 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end;
(* This is an UNSIGNED LONG comparison *)
if stack^[top-1] >= stack^[top-2] then
Stack^[top-2]:=1 else Stack^[top-2]:=0;
dec(top);
end;
(*******************************************)
(* EQ[] : EQual *)
(* CodeRange : $54 *)
$54 : begin
if top<2 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end;
(* This is an UNSIGNED LONG comparison *)
if stack^[top-1] = stack^[top-2] then
Stack^[top-2]:=1 else Stack^[top-2]:=0;
dec(top);
end;
(*******************************************)
(* NEQ[] : Not EQual *)
(* CodeRange : $55 *)
$55 : begin
if top<2 then
begin
Error:=TT_ErrMsg_Too_Few_Arguments;
goto ErrorLabel;
end;
(* This is an UNSIGNED LONG comparison *)
if stack^[top-1] <> stack^[top-2] then
Stack^[top-2]:=1 else Stack^[top-2]:=0;
dec(top);
end;
(*******************************************)
(* ODD[] : Odd *)
(* CodeRange : $56 *)
$56 : begin
if not Pop(L) then goto ErrorLabel;
L:=ToRound(L);
if L and 127 = 64 then L:=1 else L:=0;
if not Push(L) then goto ErrorLabel;
end;
(*******************************************)
(* EVEN[] : Even *)
(* CodeRange : $57 *)
$57 : begin
if not Pop(L) then goto ErrorLabel;
L:=ToRound(L);
if L and 127 = 0 then L:=1 else L:=0;
if not Push(L) then goto ErrorLabel;
end;
(*******************************************)
(* AND[] : logical AND *)
(* CodeRange : $5A *)
$5A : begin
if not Pop2( K, L ) then goto ErrorLabel;
if (K<>0) and (L<>0) then L:=1 else L:=0;
if not Push(L) then goto ErrorLabel;
end;
(*******************************************)
(* OR[] : logical OR *)
(* CodeRange : $5B *)
$5B : begin
if not Pop2( K, L ) then goto ErrorLabel;
if (K<>0) or (L<>0) then L:=1 else L:=0;
if not Push(L) then goto ErrorLabel;
end;
(*******************************************)
(* NOT[] : logical NOT *)
(* CodeRange : $5C *)
$5C : begin
if not Pop(L) then goto ErrorLabel;
if L<>0 then L:=1 else L:=0;
if not Push(L) then goto ErrorLabel;
end;
(****************************************************************)
(* *)
(* ARITHMETIC AND MATH INSTRUCTIONS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* ADD[] : ADD *)
(* CodeRange : $60 *)
$60 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if not Push(L+K) then goto ErrorLabel;
end;
(*******************************************)
(* SUB[] : SUBstract *)
(* CodeRange : $61 *)
$61 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if not Push(L-K) then goto ErrorLabel;
end;
(*******************************************)
(* DIV[] : DIVide *)
(* CodeRange : $62 *)
$62 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if K=0 then
begin
Error:=TT_ErrMsg_Divide_By_Zero;
goto ErrorLabel;
end;
if not Push( L div K ) then goto ErrorLabel;
end;
(*******************************************)
(* MUL[] : MULtiply *)
(* CodeRange : $63 *)
$63 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if not Push( L * K ) then goto ErrorLabel;
end;
(*******************************************)
(* ABS[] : ABSolute value *)
(* CodeRange : $64 *)
$64 : begin
if not Pop(L) then goto ErrorLabel;
if not Push(Abs(L)) then goto ErrorLabel;
end;
(*******************************************)
(* NEG[] : NEGate *)
(* CodeRange : $65 *)
$65 : begin
if not Pop(L) then goto ErrorLabel;
if not Push(-L) then goto ErrorLabel;
end;
(*******************************************)
(* FLOOR[] : FLOOR *)
(* CodeRange : $66 *)
$66 : begin
if not Pop(L) then goto ErrorLabel;
if not Push( L and -64 ) then goto ErrorLabel;
end;
(*******************************************)
(* CEILING[] : CEILING *)
(* CodeRange : $67 *)
$67 : begin
if not Pop(L) then goto ErrorLabel;
if not Push( (L+63) and -64 ) then goto ErrorLabel;
end;
(*******************************************)
(* MAX[] : MAXimum *)
(* CodeRange : $68 *)
$8B : begin
if not Pop2( K, L ) then goto ErrorLabel;
if K>L then L:=K;
if not Push( L ) then goto ErrorLabel;
end;
(*******************************************)
(* MIN[] : MINimum *)
(* CodeRange : $69 *)
$8C : begin
if not Pop2( K, L ) then goto ErrorLabel;
if K<L then L:=K;
if not Push( L ) then goto ErrorLabel;
end;
(****************************************************************)
(* *)
(* COMPENSATING FOR THE ENGINE CHARACTERISTICS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* ROUND[ab] : ROUND value *)
(* CodeRange : $68-$6B *)
$68..$6A : begin
if ( not Pop(L) ) then goto ErrorLabel;
Compensate( L, Opcode-$68 );
L:=ToRound(L);
if not Push(L) then goto ErrorLabel;
end;
$6B : begin
Error:=TT_ErrMsg_Invalid_Opcode;
goto ErrorLabel;
end;
(*******************************************)
(* NROUND[ab]: No ROUNDing of value *)
(* CodeRange : $6C-$6F *)
$6C..$6E : begin
if ( not Pop(L) ) then goto ErrorLabel;
Compensate( L, Opcode-$6C );
if not Push(L) then goto ErrorLabel;
end;
$6F : begin
Error := TT_ErrMsg_Invalid_Opcode;
goto ErrorLabel;
end;
(****************************************************************)
(* *)
(* DEFINING AND USING FUNCTIONS AND INSTRUCTIONS *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* FDEF[] : Function DEFinition *)
(* CodeRange : $2C *)
$2C : begin
if not Pop(L) then goto ErrorLabel;
if word(L) >= FDefs.N then
begin
Error := TT_ErrMsg_Invalid_Reference;
goto ErrorLabel;
end;
(* XXX *)
(* We could maybe do something when the function *)
(* is redefined ? *)
with FDefs.I^[L] do
begin
Range := Cur_Range;
OpCode := Opcode;
Start := IP+1;
Active := True;
end;
(* now skip the whole function definition *)
(* we don't allow nested IDEFS & FDEFs *)
while SkipCode do
case Code^[IP] of
$89, (* IDEF *)
$2C : (* FDEF *)
begin
Error := TT_ErrMsg_Nested_Defs;
goto ErrorLabel;
end;
$2D : (* ENDF *)
begin
SkipCode;
goto SuiteLabel;
end;
end;
goto ErrorLabel;
end;
(*******************************************)
(* ENDF[] : END Function definition *)
(* CodeRange : $2D *)
$2D : begin
if CallTop <= 0 then (* We encountered an ENDF without a call *)
begin
Error := TT_ErrMsg_ENDF_in_Exec_Stream;
goto ErrorLabel;
end
else
begin (* End of function call *)
dec( CallTop );
with CallStack^[CallTop] do
begin
dec( Cur_Count );
if Cur_Count > 0 then
begin
(* Loop the current function *)
IP := Cur_Restart;
inc( CallTop );
end
else
(* exit the current call frame *)
(* NOTE : When the last intruction of a program *)
(* is a CALL or LOOPCALL, the return address *)
(* is always out of the code range. This is *)
(* valid, though, which is why we do not test *)
(* the result of Goto_CodeRange here !! *)
Goto_CodeRange( Caller_Range, Caller_IP )
end;
goto SuiteLabel;
end
end;
(*******************************************)
(* CALL[] : CALL function *)
(* CodeRange : $2B *)
$2B : begin
if not Pop(L) then goto ErrorLabel;
if ( word(L) >= FDefs.N ) or
( not FDefs.I^[L].Active ) then
begin
Error := TT_ErrMsg_Invalid_Reference;
goto ErrorLabel;
end;
if CallTop >= CallSize then
begin
Error := TT_ErrMsg_Stack_Overflow;
goto ErrorLabel;
end;
with CallStack^[CallTop] do
begin
Caller_Range := Cur_Range;
Caller_IP := IP+1;
Cur_Count := 1;
Cur_Restart := FDefs.I^[L].Start;
end;
inc( CallTop );
with FDefs.I^[L] do
if not Goto_CodeRange( Range, Start ) then
goto ErrorLabel;
goto SuiteLabel;
end;
(*******************************************)
(* LOOPCALL[]: LOOP and CALL function *)
(* CodeRange : $2A *)
$2A : begin
if not Pop2( K, L ) then goto ErrorLabel;
if ( word(K) >= FDefs.N ) or
( not FDefs.I^[K].Active ) then
begin
Error := TT_ErrMsg_Invalid_Reference;
goto ErrorLabel;
end;
if CallTop >= CallSize then
begin
Error := TT_ErrMsg_Stack_Overflow;
goto ErrorLabel;
end;
if L > 0 then
begin
with CallStack^[CallTop] do
begin
Caller_Range := Cur_Range;
Caller_IP := IP+1;
Cur_Count := L;
Cur_Restart := FDefs.I^[K].Start;
end;
inc( CallTop );
with FDefs.I^[K] do
if not Goto_CodeRange( Range, Start ) then
goto ErrorLabel;
goto SuiteLabel;
end;
end;
(*******************************************)
(* IDEF[] : Instruction DEFinition *)
(* CodeRange : $89 *)
$89 : begin
if not Pop(L) then goto ErrorLabel;
A := 0;
while ( A < IDefs.N ) do
with IDefs.I^[A] do
begin
if not Active then
begin
Opcode := L;
Start := IP+1;
Range := Cur_Range;
Active := True;
A := IDefs.N;
(* now skip the whole function definition *)
(* we don't allow nested IDEFS & FDEFs *)
while SkipCode do
case Code^[IP] of
$89, (* IDEF *)
$2C : (* FDEF *)
begin
Error := TT_ErrMsg_Nested_Defs;
goto ErrorLabel;
end;
$2D : (* ENDF *)
begin
SkipCode;
goto SuiteLabel;
end;
end;
goto ErrorLabel;
end
else
inc( A );
end;
end;
(****************************************************************)
(* *)
(* PUSHING DATA ONTO THE INTERPRETER STACK *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* NPUSHB[] : PUSH N Bytes *)
(* CodeRange : $40 *)
$40 : begin
if IP+1>=CodeSize then
begin
Error:=TT_ErrMsg_Code_Overflow;
goto ErrorLabel;
end;
L:=Code^[IP+1];
if IP+1+L>=CodeSize then
begin
Error:=TT_ErrMsg_Code_Overflow;
goto ErrorLabel;
end;
for K:=1 to L do
if not Push( Code^[IP+1+K] ) then goto ErrorLabel;
end;
(*******************************************)
(* NPUSHW[] : PUSH N Words *)
(* CodeRange : $41 *)
$41 : begin
if IP+1>=CodeSize then
begin
Error:=TT_ErrMsg_Code_Overflow;
goto ErrorLabel;
end;
L:=Code^[IP+1];
if IP+1+2*L>=CodeSize then
begin
Error:=TT_ErrMsg_Code_Overflow;
goto ErrorLabel;
end;
inc( IP, 2 );
for K:=1 to L do
begin
A:=GetShort;
if not Push( A ) then goto ErrorLabel;
end;
goto SuiteLabel;
end;
(*******************************************)
(* PUSHB[abc]: PUSH Bytes *)
(* CodeRange : $B0-$B7 *)
$B0..$B7 : begin
L:=Opcode-$B0+1;
if IP+L>=CodeSize then
begin
Error:=TT_ErrMsg_Code_Overflow;
goto ErrorLabel;
end;
for K:=1 to L do
if not Push( Code^[IP+K] ) then goto ErrorLabel;
end;
(*******************************************)
(* PUSHW[abc]: PUSH Words *)
(* CodeRange : $B8-$BF *)
$B8..$BF : begin
L:=Opcode-$B8+1;
if IP+2*L>=CodeSize then
begin
Error:=TT_ErrMsg_Code_Overflow;
goto ErrorLabel;
end;
inc( IP );
for K:=1 to L do
begin
A := GetShort;
if not Push( A ) then goto ErrorLabel;
end;
goto SuiteLabel;
end;
(****************************************************************)
(* *)
(* MANAGING THE STORAGE AREA *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* RS[] : Read Store *)
(* CodeRange : $43 *)
$43 : begin
if not Pop(L) then goto ErrorLabel;
if L>=StoreSize then
begin
Error:=TT_ErrMsg_Storage_Overflow;
goto ErrorLabel;
end;
if not Push( Storage^[L] ) then goto ErrorLabel;
end;
(*******************************************)
(* WS[] : Write Store *)
(* CodeRange : $42 *)
$42 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if L>=StoreSize then
begin
Error:=TT_ErrMsg_Storage_Overflow;
goto ErrorLabel;
end;
Storage^[L]:=K;
end;
(*******************************************)
(* WCVTP[] : Write CVT in Pixel units *)
(* CodeRange : $44 *)
$44 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if L>=CvtSize then
begin
Error:=TT_ErrMsg_CVT_Overflow;
goto ErrorLabel;
end;
CVT^[L]:=K;
end;
(*******************************************)
(* WCVTF[] : Write CVT in FUnits *)
(* CodeRange : $70 *)
$70 : begin
if not Pop2( K, L ) then goto ErrorLabel;
if L>=CvtSize then
begin
Error:=TT_ErrMsg_CVT_Overflow;
goto ErrorLabel;
end;
CVT^[L]:=Scaled(K);
end;
(*******************************************)
(* RCVT[] : Read CVT *)
(* CodeRange : $45 *)
$45 : begin
if not Pop( L ) then goto ErrorLabel;
if L >= CvtSize then
begin
Error:=TT_ErrMsg_CVT_Overflow;
goto ErrorLabel;
end;
if not Push( CVT^[L] ) then goto ErrorLabel;
end;
(****************************************************************)
(* *)
(* MANAGING THE GRAPHICS STATE *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(*******************************************)
(* SVTCA[a] : Set F and P vectors to axis *)
(* CodeRange : $00-$01 *)
$00..$01 : begin
Case OpCode and 1 of
0 : A:=$0000;
1 : A:=$4000;
end;
B:=A xor $4000;
GS.projVector.x:=A;
GS.projVector.y:=B;
GS.freeVector.x:=A;
GS.freeVector.y:=B;
end;
(*******************************************)
(* SPVTCA[a] : Set PVector to Axis *)
(* CodeRange : $02-$03 *)
$02..$03 : begin
Case OpCode and 1 of
0 : A:=$0000;
1 : A:=$4000;
end;
B:=A xor $4000;
GS.projVector.x:=A;
GS.projVector.y:=B;
end;
(*******************************************)
(* SFVTCA[a] : Set FVector to Axis *)
(* CodeRange : $04-$05 *)
$04..$05 : begin
Case OpCode and 1 of
0 : A:=$0000;
1 : A:=$4000;
end;
B:=A xor $4000;
GS.freeVector.x:=A;
GS.freeVector.y:=B;
end;
(*******************************************)
(* SPVTL[a] : Set PVector to Line *)
(* CodeRange : $06-$07 *)
$06..$07 : begin
if not PopPoint2( K, L, zp1.N, zp2.N ) then
goto ErrorLabel;
A:= zp2.Cur^[L].x-zp1.Cur^[K].x;
B:= zp2.Cur^[L].y-zp1.Cur^[K].y;
if OpCode and 1 <> 0 then
begin
C:=B; (* CounterClockwise rotation *)
B:=A;
A:=-C;
end;
if not Normalize( A, B, GS.projVector )
then goto ErrorLabel;
end;
(*******************************************)
(* SFVTL[a] : Set FVector to Line *)
(* CodeRange : $08-$09 *)
$08..$09 : begin
if not PopPoint2( K, L, zp1.N, zp2.N ) then
goto ErrorLabel;
A:= zp2.Cur^[L].x-zp1.Cur^[K].x;
B:= zp2.Cur^[L].y-zp1.Cur^[K].y;
if OpCode and 1 <> 0 then
begin
C:=B; (* CounterClockwise rotation *)
B:=A;
A:=-C;
end;
if not Normalize( A, B, GS.freeVector )
then goto ErrorLabel;
end;
(*******************************************)
(* SFVTPV[] : Set FVector to PVector *)
(* CodeRange : $0E *)
$0E : with GS do freeVector := projVector;
(*******************************************)
(* SDPVTL[a] : Set Dual PVector to Line *)
(* CodeRange : $86-$87 *)
$86..$87 : begin
if not PopPoint2( K, L, Pts.N, Pts.N ) then
goto ErrorLabel;
A:= Pts.Org^[L].x-Pts.Org^[K].x;
B:= Pts.Org^[L].y-Pts.Org^[K].y;
if OpCode = $89 then
begin
C:=B; (* CounterClockwise rotation *)
B:=A;
A:=-C;
end;
if not Normalize( A, B, GS.dualVector )
then goto ErrorLabel;
end;
(*******************************************)
(* SPVFS[] : Set PVector From Stack *)
(* CodeRange : $0A *)
$0A : begin
if not Pop2( K, L ) then goto ErrorLabel;
S:=K; K:=S; (* Type Conversion, extends sign *)
S:=L; L:=S; (* Type conversion, extends sign *)
if not Normalize( L, K, GS.projVector )
then goto ErrorLabel;
end;
(*******************************************)
(* SFVFS[] : Set FVector From Stack *)
(* CodeRange : $0B *)
$0B : begin
if not Pop2( K, L ) then goto ErrorLabel;
S:=K; K:=S; (* Type Conversion, extends sign *)
S:=L; L:=S; (* Type conversion, extends sign *)
if not Normalize( L, K, GS.freeVector )
then goto ErrorLabel;
end;
(*******************************************)
(* GPV[] : Get Projection Vector *)
(* CodeRange : $0C *)
$0C : begin
(* Type Conversion *)
with GS.projVector do
if not Push2( word(x), word(y) ) then
goto ErrorLabel;
end;
(*******************************************)
(* GFV[] : Get Freedom Vector *)
(* CodeRange : $0D *)
$0D : begin
(* Type Conversion *)
with GS.freeVector do
if not Push2( word(x), word(y) ) then
goto ErrorLabel;
end;
(*******************************************)
(* SRP0[] : Set Reference Point 0 *)
(* CodeRange : $10 *)
$10 : begin
if not Pop(L) then goto ErrorLabel;
GS.RP0:=L;
end;
(*******************************************)
(* SRP1[] : Set Reference Point 1 *)
(* CodeRange : $11 *)
$11 : begin
if not Pop(L) then goto ErrorLabel;
GS.RP1:=L;
end;
(*******************************************)
(* SRP2[] : Set Reference Point 2 *)
(* CodeRange : $12 *)
$12 : begin
if not Pop(L) then goto ErrorLabel;
GS.RP2:=L;
end;
(*******************************************)
(* SZP0[] : Set Zone Pointer 0 *)
(* CodeRange : $13 *)
$13 : begin
if not PopPoint( L, 2 ) then goto ErrorLabel;
GS.Gep0:=L;
if L=0 then zp0:=Twilight else zp0:=Pts;
end;
(*******************************************)
(* SZP1[] : Set Zone Pointer 1 *)
(* CodeRange : $14 *)
$14 : begin
if not PopPoint( L, 2 ) then goto ErrorLabel;
GS.Gep1:=L;
if L=0 then zp1:=Twilight else zp1:=Pts;
end;
(*******************************************)
(* SZP2[] : Set Zone Pointer 2 *)
(* CodeRange : $15 *)
$15 : begin
if not PopPoint( L, 2 ) then goto ErrorLabel;
GS.Gep2:=L;
if L=0 then zp2:=Twilight else zp2:=Pts;
end;
(*******************************************)
(* SZPS[] : Set Zone Pointers *)
(* CodeRange : $16 *)
$16 : begin
if not PopPoint( L, 2 ) then goto ErrorLabel;
GS.Gep0:=L; if L=0 then zp0:=Twilight else zp0:=Pts;
GS.Gep1:=L; zp1:=zp0;
GS.Gep2:=L; zp2:=zp0;
end;
(*******************************************)
(* RTHG[] : Round To Half Grid *)
(* CodeRange : $19 *)
$19 : GS.RoundState:=TTRoundToHalfGrid;
(*******************************************)
(* RTG[] : Round To Grid *)
(* CodeRange : $18 *)
$18 : GS.RoundState:=TTRoundToGrid;
(*******************************************)
(* RTDG[] : Round To Double Grid *)
(* CodeRange : $3D *)
$3D : GS.RoundState:=TTRoundToDoubleGrid;
(*******************************************)
(* RUTG[] : Round Up To Grid *)
(* CodeRange : $7C *)
$7C : GS.RoundState:=TTRoundUpToGrid;
(*******************************************)
(* RDTG[] : Round Down To Grid *)
(* CodeRange : $7D *)
$7D : GS.RoundState:=TTRoundDownToGrid;
(*******************************************)
(* ROFF[] : Round OFF *)
(* CodeRange : $7A *)
$7A : GS.RoundState:=TTRoundOff;
(*******************************************)
(* SROUND[] : Super ROUND *)
(* CodeRange : $76 *)
$76 : begin
if not Pop(L) then goto ErrorLabel;
SetSuperRound( $4000, L );
GS.RoundState:=TTRoundSuper;
end;
(*******************************************)
(* S45ROUND[]: Super ROUND 45 degrees *)
(* CodeRange : $77 *)
$77 : begin
if not Pop(L) then goto ErrorLabel;
SetSuperRound( $2D41, L );
GS.RoundState:=TTRoundSuper;
end;
(*******************************************)
(* SLOOP[] : Set LOOP variable *)
(* CodeRange : $17 *)
$17 : begin
if not Pop(L) then goto ErrorLabel;
GS.Loop:=L;
end;
(*******************************************)
(* SMD[] : Set Minimium Distance *)
(* CodeRange : $1A *)
$1A : begin
if not Pop(L) then goto ErrorLabel;
GS.minimumDistance := L;
end;
(*******************************************)
(* INSTCTRL[]: INSTruction ConTRoL *)
(* CodeRange : $8E *)
$8E : begin
if not Pop2( K, L ) then goto ErrorLabel;
if ( K < 1 ) or ( K > 2 ) then
begin
Error := TT_ErrMsg_Bad_Argument;
goto ErrorLabel;
end;
if L <> 0 then L := K;
GS.instructControl := (GS.instructControl and not K) or L;
end;
(*******************************************)
(* SCANCTRL[]: SCAN ConTRol *)
(* CodeRange : $85 *)
$85 : begin
if not Pop( K ) then goto ErrorLabel;
(* XXXX TO DO *)
GS.scanControl := True;
end;
(*******************************************)
(* SCANTYPE[]: SCAN TYPE *)
(* CodeRange : $8D *)
$8D : begin
if not Pop(K) then goto ErrorLabel;
(* XXXX TO DO *)
end;
(**********************************************)
(* SCVTCI[] : Set Control Value Table Cut In *)
(* CodeRange : $1D *)
$1D : begin
if not Pop(L) then goto ErrorLabel;
GS.controlValueCutIn := L;
end;
(**********************************************)
(* SSWCI[] : Set Single Width Cut In *)
(* CodeRange : $1E *)
$1E : begin
if not Pop(L) then goto ErrorLabel;
GS.singleWidthCutIn := L;
end;
(**********************************************)
(* SSW[] : Set Single Width *)
(* CodeRange : $1F *)
$1F : begin
if not Pop(L) then goto ErrorLabel;
GS.singleWidthValue := L;
end;
(**********************************************)
(* FLIPON[] : Set Auto_flip to On *)
(* CodeRange : $4D *)
$4D : GS.autoFlip := TRUE;
(**********************************************)
(* FLIPOFF[] : Set Auto_flip to Off *)
(* CodeRange : $4E *)
$4E : GS.autoFlip := FALSE;
(**********************************************)
(* SANGW[] : Set Angle Weigth *)
(* CodeRange : $7E *)
$7E : begin
end; (* This instruction is not supported anymore *)
(**********************************************)
(* SDB[] : Set Delta Base *)
(* CodeRange : $5E *)
$5E : begin
if not Pop(L) then goto ErrorLabel;
GS.deltaBase := L;
end;
(**********************************************)
(* SDS[] : Set Delta Shift *)
(* CodeRange : $5F *)
$5F : begin
if not Pop(L) then goto ErrorLabel;
GS.deltaShift := L;
end;
(**********************************************)
(* GC[a] : Get Coordinate projected onto *)
(* CodeRange : $46-$47 *)
$46..$47 : begin
if not PopPoint( L, zp2.N ) then goto ErrorLabel;
case Opcode and 1 of
0 : L:= Project( zp2.Org^[L], GS.projVector );
1 : L:= Project( zp2.Cur^[L], GS.projVector );
end;
if not Push( L ) then
goto ErrorLabel;
end;
(**********************************************)
(* SCFS[] : Set Coordinate From Stack *)
(* CodeRange : $48 *)
(* *)
(* Formule : *)
(* *)
(* OA := OA + ( value - OA.p )/( f.p ) x f *)
(* *)
$48 : begin
if not Pop(K) or not PopPoint( L, zp2.N ) then
goto ErrorLabel;
if not MoveVec2( zp2.Cur^[L], K, zp2.Cur^[L] ) then
goto ErrorLabel;
end;
(**********************************************)
(* MD[a] : Measure Distance *)
(* CodeRange : $49-$4A *)
$49..$4A : begin
if not PopPoint2( K, L, zp0.n, zp1.n ) then
goto ErrorLabel;
Case opcode and 1 of
1 : begin
Vec.x := zp1.Org^[L].x - zp0.Org^[L].x;
Vec.y := zp1.Org^[L].y - zp1.Org^[L].y;
end;
0 : begin
Vec.x := zp1.Cur^[L].x - zp0.Cur^[L].x;
Vec.y := zp1.Cur^[L].y - zp0.Cur^[L].y;
end;
end;
L := Project( Vec, GS.projVector );
if not Push(L) then goto ErrorLabel;
end;
(**********************************************)
(* MPPEM[] : Measure Pixel Per EM *)
(* CodeRange : $4B *)
$4B : if not Push( Scale1 div 72 ) then
goto ErrorLabel;
(* NOTE : we return an integer, not a F26dot6 !! *)
(* XXXX and we ASSUME a device with SQUARE pixels *)
(**********************************************)
(* MPS[] : Measure PointSize *)
(* CodeRange : $4C *)
$4C : if not Push( PointSize ) then goto ErrorLabel;
(****************************************************************)
(* *)
(* MANAGING OUTLINES *)
(* *)
(* Instructions appear in the specs' order *)
(* *)
(****************************************************************)
(**********************************************)
(* FLIPPT[] : FLIP PoinT *)
(* CodeRange : $80 *)
$80 : begin
if not PopPoint( L, pts.N ) then goto ErrorLabel;
Pts.Touch^[L] := Pts.Touch^[L] xor TTFlagOnCurve;
(* Do we need to use Loop ?? *)
end;
(**********************************************)
(* FLIPRGON[]: FLIP RanGe ON *)
(* CodeRange : $81 *)
$81 : begin
if not PopPoint2( K, L, Pts.N, Pts.N ) then
goto ErrorLabel;
for A:=L to K do
Pts.Touch^[L] := Pts.Touch^[L] or TTFlagOnCurve;
end;
(**********************************************)
(* FLIPRGOFF : FLIP RanGe OFF *)
(* CodeRange : $82 *)
$82 : begin
if not PopPoint2( K, L, Pts.N, Pts.N ) then
goto ErrorLabel;
for A:=L to K do
Pts.Touch^[L] := Pts.Touch^[L] and not TTFlagOnCurve;
end;
(**********************************************)
(* SHP[a] : SHift Point by the last point *)
(* CodeRange : $32-33 *)
$32..$33 : begin
if not PopPoint( L, zp2.n ) then
goto ErrorLabel;
case Opcode and 1 of
0 : begin A := GS.rp2; zp := zp1; end;
1 : begin A := GS.rp1; zp := zp0; end;
end;
if A>zp.N then
begin
Error:=TT_ErrMsg_Invalid_Reference;
goto ErrorLabel;
end;
Vec.x := zp.Cur^[A].x - zp.Org^[A].x;
Vec.y := zp.Cur^[A].y - zp.Org^[A].y;
K := Project( Vec, GS.projVector );
if not MoveVec1( zp2.Cur^[L], K ) then goto ErrorLabel;
Touch( zp2.Touch^[L] );
end;
(**********************************************)
(* SHC[a] : SHift Contour *)
(* CodeRange : $34-35 *)
$34..$35 : begin
if not PopPoint( L, Contours.N ) then
goto ErrorLabel;
case Opcode and 1 of
0 : begin A := GS.rp2; zp := zp1; end;
1 : begin A := GS.rp1; zp := zp0; end;
end;
if A >= zp.N then
begin
Error:=TT_ErrMsg_Invalid_Reference;
goto ErrorLabel;
end;
Vec.x := zp.Cur^[A].x - zp.Org^[A].x;
Vec.y := zp.Cur^[A].y - zp.Org^[A].y;
K := Project( Vec, GS.projVector );
if zp.Cur <> zp2.Cur then
begin
with Contours.C^[L] do
for I:=First to Last do
begin
if not MoveVec1( zp2.Cur^[I], K ) then goto ErrorLabel;
Touch( zp2.Touch^[I] );
end
end
else
(* We must not move the reference point if it is *)
(* the current glyph *)
with Contours.C^[L] do
for I:=First to Last do
if I<>A then if not MoveVec1( zp2.Cur^[I], K ) then
goto ErrorLabel
else
Touch( zp2.Touch^[I] );
end;
(**********************************************)
(* SHZ[a] : SHift Zone *)
(* CodeRange : $36-37 *)
$36..$37 : begin
if not PopPoint( L, 2 ) then
goto ErrorLabel;
if L<>0 then zp2:=Pts else zp2:=Twilight;
case Opcode and 1 of
0 : begin A := GS.rp2; zp := zp1; end;
1 : begin A := GS.rp1; zp := zp0; end;
end;
if A>zp.N then
begin
Error:=TT_ErrMsg_Invalid_Reference;
goto ErrorLabel;
end;
Vec.x := zp.Cur^[A].x - zp.Org^[A].x;
Vec.y := zp.Cur^[A].y - zp.Org^[A].y;
K := Project( Vec, GS.projVector );
(* NOTE : The Reference Point will be *)
(* shifted with all other points *)
for I:=0 to zp.N-1 do
if not MoveVec1( zp2.Cur^[I], K ) then
goto ErrorLabel;
end;
(**********************************************)
(* SHPIX[] : SHift points by a PIXel amount *)
(* CodeRange : $38 *)
$38 : begin
if not Pop(L) then goto ErrorLabel;
A := MulDiv( GS.freeVector.x, L, $4000 );
B := MulDiv( GS.freeVector.y, L, $4000 );
while GS.loop > 0 do
begin
if not PopPoint( K, zp2.N ) then goto ErrorLabel;
with zp2.Cur^[K] do
begin
inc( X, A );
inc( Y, B );
end;
Touch( zp2.Touch^[K] );
dec( GS.loop );
end;
end;
(**********************************************)
(* MSIRP[a] : Move Stack Indirect Relative *)
(* CodeRange : $3A-$3B *)
$3A..$3B : begin
if not Pop(L) or not PopPoint( K, zp1.N )
then goto ErrorLabel;
with zp1.Cur^[K] do
begin
Vec.x := x - zp0.Cur^[GS.rp0].x;
Vec.y := y - zp0.Cur^[GS.rp0].y;
end;
if not MoveVec2( zp1.Cur^[K], L, Vec ) then
goto ErrorLabel;
Touch( zp1.Touch^[K] );
if Opcode and 1 <> 0 then GS.rp0 := K;
end;
(**********************************************)
(* MDAP[a] : Move Direct Absolute Point *)
(* CodeRange : $2E-$2F *)
$2E..$2F : begin
if not PopPoint( L, zp0.N ) then
goto ErrorLabel;
GS.rp0 := L;
GS.rp1 := L;
if Opcode and 1 <> 0 then RoundPoint( zp0.Cur^[L] );
Touch( zp0.Touch^[L] );
end;
(**********************************************)
(* MIAP[a] : Move Indirect Absolute Point *)
(* CodeRange : $3E-$3F *)
$3E..$3F : begin
if not PopPoint( K, CVTSize ) or
not PopPoint( L, zp0.N ) then
goto ErrorLabel;
K := CVT^[K];
if OpCode and 1 <> 0 then
begin
A := Project( zp0.Cur^[L], GS.projVector );
(* XXX TODO : autoflip *)
if Abs( K-A ) > GS.controlValueCutIn then K:=A;
K:=ToRound(K);
end;
with zp0.Cur^[L] do
begin
X := MulDiv( GS.projVector.x, K, $4000 );
Y := MulDiv( GS.projVector.y, K, $4000 );
end;
zp0.Touch^[L] := zp0.Touch^[L] or TTFlagTouchedBoth;
GS.rp0 := L;
GS.rp1 := L;
end;
(**********************************************)
(* MDRP[abcde] : Move Direct Relative Point *)
(* CodeRange : $C0-$DF *)
$C0..$DF : begin
if not PopPoint( L, zp1.N ) then
goto ErrorLabel;
Vec.x := zp1.Org^[L].x - zp0.Org^[GS.rp0].x;
Vec.y := zp1.Org^[L].y - zp0.Org^[GS.rp0].y;
K := Project( Vec, GS.projVector );
if K>=0 then Sign:=False
else
begin
Sign:=True;
K:=-K;
end;
if K < GS.singleWidthCutIn then
K := GS.singleWidthValue;
if Opcode and 8 <> 0 then
if K<GS.minimumDistance then K:=GS.minimumDistance;
if Opcode and 4 <> 0 then
K := ToRound(K);
if not Compensate( K, Opcode and 3 ) then
goto ErrorLabel;
if Sign then K:=-K;
Vec.x := zp1.Cur^[L].x - zp0.Cur^[GS.rp0].x;
Vec.y := zp1.Cur^[L].y - zp0.Cur^[GS.rp0].y;
if not MoveVec2( zp1.Cur^[L], K, Vec ) then
goto ErrorLabel;
Touch( zp1.Touch^[L] );
if Opcode and 16 <> 0 then GS.rp0 := L;
end;
(**********************************************)
(* MIRP[abcde] : Move Indirect Relative Point *)
(* CodeRange : $E0-$FF *)
$E0..$FF : begin
if not PopPoint2( K, L, CVTSize, zp1.N ) then
goto ErrorLabel;
Vec.x := zp1.Cur^[L].x - zp0.Cur^[GS.rp0].x;
Vec.y := zp1.Cur^[L].y - zp0.Cur^[GS.rp0].y;
A := Project( Vec, GS.projVector );
if A>=0 then Sign:=False
else
begin
Sign:=True;
A:=-A;
end;
if Opcode and 4 <> 0 then
if A < GS.controlValueCutIn then
A := CVT^[K];
if A < GS.singleWidthCutIn then
A := GS.singleWidthValue;
if Opcode and 8 <> 0 then
if A<GS.minimumDistance then A:=GS.minimumDistance;
if Opcode and 4 <> 0 then
A:=ToRound(A);
if not Compensate( A, Opcode and 3 ) then
goto ErrorLabel;
if Sign then A:=-A;
(* XXX TODO autoflip *)
if not MoveVec2( zp1.Cur^[L], K, Vec ) then
goto ErrorLabel;
Touch( zp1.Touch^[L] );
if Opcode and 16 <> 0 then GS.rp0 := L;
end;
(**********************************************)
(* ALIGNRP[] : ALIGN Relative Point *)
(* CodeRange : $3C *)
$3C : begin
if not PopPoint( L, zp1.N ) then
goto ErrorLabel;
Vec.x := zp1.Cur^[L].x - zp0.Cur^[GS.rp0].x;
Vec.y := zp1.Cur^[L].y - zp0.Cur^[GS.rp0].y;
if not MoveVec2( zp1.Cur^[L], 0, Vec ) then
goto ErrorLabel;
Touch( zp1.Touch^[L] );
end;
(**********************************************)
(* AA[] : Adjust Angle *)
(* CodeRange : $7F *)
$7F : ; (* Intentional - no longer supported *)
(**********************************************)
(* ISECT[] : moves point to InterSECTion *)
(* CodeRange : $0F *)
$0F : begin
if not PopPoint2( L, K, zp0.N, zp0.N ) or
not PopPoint2( B, A, zp1.N, zp1.N ) or
not PopPoint( C, zp2.N ) then
goto ErrorLabel;
if not Intersect( zp1.Cur^[K], zp1.Cur^[L],
zp0.Cur^[A], zp0.Cur^[B],
Vec )
then goto ErrorLabel;
zp2.Cur^[C] := Vec;
Touch( zp2.Touch^[C] );
end;
(**********************************************)
(* ALIGNPTS[] : ALIGN PoinTS *)
(* CodeRange : $27 *)
$27 : begin
if not PopPoint2( K, L, zp0.N, zp1.N ) or
not AlignVecs( zp0.Cur^[K], zp1.Cur^[L] )
then
goto ErrorLabel;
zp0.Touch^[K] := zp0.Touch^[K] or TTFlagTouchedBoth;
zp1.Touch^[L] := zp1.Touch^[L] or TTFlagTouchedBoth;
end;
(**********************************************)
(* IP[] : Interpolate Point *)
(* CodeRange : $39 *)
$39 : begin
if not PopPoint( K, zp2.N ) then
goto ErrorLabel;
if not Barycentre( zp0.Org^[GS.rp1],
zp1.Org^[GS.rp2],
zp2.Org^[K],
zp0.Cur^[GS.rp1],
zp1.Cur^[GS.rp2],
zp2.Cur^[K]
)
then
goto ErrorLabel;
Touch( zp2.Touch^[K] );
end;
(**********************************************)
(* UTP[a] : UnTouch Point *)
(* CodeRange : $29 *)
$29 : begin
if not PopPoint( K, zp0.N ) then
goto ErrorLabel;
zp0.Touch^[K] := zp0.Touch^[K] and not TTFlagTouchedBoth;
end;
(**********************************************)
(* IUP[a] : Interpolate Untouched Points *)
(* CodeRange : $30-$31 *)
$30 : begin
if zp2.Cur = Twilight.Cur then
begin
Error := TT_ErrMsg_Interpolate_Twilight;
goto ErrorLabel;
end;
with Pts, Contours do
for A := 0 to N-1 do
with C^[A] do
for B := First to Last do
begin
if B = First then K:=Last else K:=B-1;
if B = Last then L:=First else L:=L+1;
if ( (not Touch^[B]) and (Touch^[K] and Touch^[L]) )
and TTFlagTouchedY <> 0
then
if not Interpolate( Org^[K].y,
Org^[L].y,
Org^[B].y,
Cur^[K].y,
Cur^[L].y,
Cur^[B].y
)
then
goto ErrorLabel;
end;
end;
$31 : begin
if zp2.Cur = Twilight.Cur then
begin
Error := TT_ErrMsg_Interpolate_Twilight;
goto ErrorLabel;
end;
with Pts, Contours do
for A := 0 to N-1 do
with C^[A] do
for B := First to Last do
begin
if B = First then K:=Last else K:=B-1;
if B = Last then L:=First else L:=L+1;
if ( (not Touch^[B]) and (Touch^[K] and Touch^[L]) )
and TTFlagTouchedX <> 0
then
if not Interpolate( Org^[K].x,
Org^[L].x,
Org^[B].x,
Cur^[K].x,
Cur^[L].x,
Cur^[B].x
)
then
goto ErrorLabel;
end;
end;
(**********************************************)
(* DELTAPn[] : DELTA Exceptions P1, P2, P3 *)
(* CodeRange : $5D,$71,$72 *)
$5D,
$71,
$72 : begin
if not Pop(L) then goto ErrorLabel;
for K:=1 to L do
begin
if not PopPoint( A, zp0.N ) or
not Pop(B)
then
goto ErrorLabel;
C := ( B and $F0 ) shr 4;
Case OpCode of
$5D : ;
$71 : C := C-16;
$72 : C := C-32;
end;
C := C + GS.deltaBase;
if PointSize div 64 = C then
begin
B := (B and $F) - 8;
if B >= 0 then B:=B+1;
B := ( B*64 ) div ( 1 shl GS.deltaShift );
with zp0.Cur^[A] do
begin
inc( X, B*GS.freeVector.x div $4000 );
inc( Y, B*GS.freeVector.y div $4000 );
end;
Touch( zp0.Touch^[A] );
end;
end;
end;
(**********************************************)
(* DELTACn[] : DELTA Exceptions C1, C2, C3 *)
(* CodeRange : $73,$74,$75 *)
$73..$75 : begin
if not Pop(L) then goto ErrorLabel;
for K:=1 to L do
begin
if not PopPoint( A, CvtSize ) or
not Pop(B)
then
goto ErrorLabel;
C := ( B and $F0 ) shr 4;
Case OpCode of
$73 : ;
$74 : C := C-16;
$75 : C := C-32;
end;
C := C + GS.deltaBase;
if PointSize div 64 = C then
begin
B := (B and $F) - 8;
if B >= 0 then B:=B+1;
B := ( B*64 ) div ( 1 shl GS.deltaShift );
inc( CVT^[A], B );
end;
end;
end;
(****************************************************************)
(* *)
(* MISC. INSTRUCTIONS *)
(* *)
(****************************************************************)
(***********************************************************)
(* DEBUG[] : DEBUG. Unsupported *)
(* CodeRange : $4F *)
(* NOTE : The original instruction pops a value from the stack *)
$4F : begin
Error := TT_ErrMsg_Debug_Opcode;
goto ErrorLabel;
end;
(**********************************************)
(* GETINFO[] : GET INFOrmation *)
(* CodeRange : $88 *)
$88 : begin
if not Pop(L) then goto ErrorLabel;
K:=0;
if L and 1 <> 0 then K := 3;
(* We return then Windows 3.1 version number *)
(* for the font scaler *)
if false then K:=K or $80;
(* Has the glyph been rotated ? *)
(* XXXX TO DO *)
if false then K:=K or $100;
(* Has the glyph been stretched ? *)
(* XXXX TO DO *)
if not Push(K) then goto ErrorLabel;
end;
else
(*******************************************)
(* Instructions définies par le programme *)
(* au moyen de IDEF/ENDI *)
A := 0;
while ( A < IDefs.N ) do
with IDefs.I^[A] do
if Active and ( Opcode = Opc ) then
begin
if CallTop >= CallSize then
begin
Error := TT_ErrMsg_Invalid_Reference;
goto ErrorLabel;
end;
with CallStack^[CallTop] do
begin
Caller_Range := Cur_Range;
Caller_IP := IP+1;
Cur_Count := 1;
Cur_Restart := Start;
end;
if not Goto_CodeRange( Range, Start ) then
goto ErrorLabel;
goto SuiteLabel;
end
else
inc(A);
Error := TT_ErrMsg_Invalid_Opcode;
goto ErrorLabel;
end;
SkipCode;
SuiteLabel:
if (IP >= CodeSize) then
if CallTop > 0 then
begin
Error := TT_ErrMsg_Code_Overflow;
goto ErrorLabel;
end
else
goto No_Error;
until Instruction_Trap;
No_Error:
Run := True;
exit;
ErrorLabel:
(********************************************)
(* An error occured during execution. Quit *)
(* quietly then.. *)
Run := False;
end;
(********************)
(* Init_Interpreter *)
(***********************************************************************)
(* *)
(* This routine must be called before any execution, after the max *)
(* profile table has been loaded. *)
(* *)
(* Please make sure the Font Storage Pool and the CVT have been *)
(* allocated prior to any execution.. *)
function Init_Interpreter( var Max : TMaxProfile ) : boolean;
var
i, n : int;
begin
Init_Interpreter := False;
Error := TT_ErrMsg_Storage_Overflow;
(* First, allocate the stack segment *)
if not Alloc( Max.maxStackElements * sizeof(LongInt), Pointer(Stack) )
then exit;
StackSize := Max.maxStackElements;
(* Second, allocate Function & Instruction Defs tables *)
IDefs.N := Max.maxInstructionDefs;
if not Alloc( IDefs.N * sizeof( TDefRecord ), Pointer(IDefs.I) )
then exit;
for i := 0 to IDefs.N-1 do
IDefs.I^[i].Active := False;
FDefs.N := Max.maxFunctionDefs;
if not Alloc( FDefs.N * sizeof( TDefRecord ), Pointer(FDefs.I) )
then exit;
for i := 0 to FDefs.N-1 do
FDefs.I^[i].Active := False;
(* Third, init the call stack, we currently support 8 nested calls *)
CallTop := 0;
CallSize := 0;
if not Alloc( sizeof(TCallRecord)*8, Pointer(CallStack) )
then exit;
CallSize := 8;
(* Fourth, init the storage area, to zero *)
Storage := nil;
StoreSize := 0;
if not Alloc( Max.maxStorage*4, Pointer(Storage) )
then exit;
StoreSize := Max.maxStorage;
(* Fifth, allocate the Two zones *)
n := sizeof(TVector) * Max.maxTwilightPoints;
if not Alloc( n, Pointer( Twilight.Org ) ) or
not Alloc( n, Pointer( Twilight.Cur ) ) or
not Alloc( Max.maxTwilightPoints, Pointer( Twilight.Touch ) ) then exit;
for i := 0 to Max.maxTwilightPoints-1 do with Twilight.Org^[i] do
begin
x := 0;
y := 0;
end;
for i := 0 to Max.maxTwilightPoints-1 do Twilight.Touch^[i]:=0;
move( Twilight.Org^, Twilight.Cur^, n );
Twilight.N := Max.maxTwilightPoints;
(* Init the instruction pointer, this should be changed later by *)
(* others parts of the program *)
Cur_Range := 0;
CodeRanges := 0;
Code := nil;
IP := 0;
CodeSize := 0;
Instruction_Trap := False;
Pts.N := 0;
Pts.Org := nil;
Pts.Cur := nil;
zp0 := Pts;
zp1 := Pts;
zp2 := Pts;
Init_Interpreter := True;
end;
end.
